home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / aegis_float.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  4.7 KB  |  170 lines
  1. (herald aegis_float (env tsys))
  2.  
  3. (define-integrable (make-flonum)
  4.   (make-vector-extend header/double-float 2 2 ))
  5.  
  6. ;++ this should be written in T.
  7.  
  8. (define (kludgy-string->flonum s)
  9.   (let ((s (if (iob? s) (buffer->string! s) s))
  10.         (n (make-flonum))
  11.         (b (get-string-buffer)))
  12.     (set (string-length b) (text-length (string-text b)))
  13.     (string-fill b #\space)
  14.     (string-replace b s (string-length s))
  15.     (t_$atod b n)
  16.     (release-string-buffer b)
  17.     n))
  18.  
  19. (define-foreign t_$atod
  20.   ("T_$ATOD" (in rep/string)
  21.            (out rep/extend))
  22.     ignore)
  23.  
  24. ;; expects a string of length at least 23
  25.  
  26. ;++ flush
  27. ;(define-integrable (kludgy-flonum->string! n s)
  28. ;  (t_$dtoa s n)
  29. ;  s)
  30.  
  31. (define-foreign t_$dtoa
  32.   ("T_$DTOA" (out rep/string)
  33.            (in rep/extend))
  34.     ignore)
  35.  
  36. (define (print-flonum-kludgily n stream)
  37.   (let ((b (get-string-buffer)))
  38.     (set (string-length b) 23)
  39.     (string-fill b #\space)
  40.     (t_$dtoa b n)
  41.     (write-string stream b)
  42.     (release-string-buffer b)
  43.     (no-value)))
  44.  
  45. (define (*define-fl-proc-1 xenoid id)
  46.   (object (lambda (x)
  47.             (let ((x (enforce double-float? x))
  48.                   (result (make-flonum)))
  49.               (xenoid x result)
  50.               result))
  51.           ((identification self) id)))
  52.  
  53. (define (*define-fl-proc-2 xenoid id)
  54.   (object (lambda (x y)
  55.             (let ((x (enforce double-float? x))
  56.                   (y (enforce double-float? y))
  57.                   (result (make-flonum)))
  58.               (xenoid x y result)
  59.               result))
  60.           ((identification self) id)))
  61.  
  62. (define (*define-fl-proc-3 xenoid id)
  63.   (object (lambda (x y)
  64.             (let ((x (enforce double-float? x))
  65.                   (y (enforce double-float? y)))
  66.               (fixnum-odd? (xenoid x y))))
  67.           ((identification self) id)))
  68.                     
  69. (define-local-syntax (define-fl-proc-1 name)
  70.   (let ((xeno-name (concatenate-symbol 't_$ name)))
  71.     `(block (define-foreign ,xeno-name 
  72.               (,(string-upcase! (symbol->string xeno-name)) (in rep/extend)
  73.                           (out rep/extend))
  74.               ignore)
  75.             (define ,name (*define-fl-proc-1 ,xeno-name ',name)))))
  76.   
  77.  
  78. (define-local-syntax (define-fl-proc-2 name)
  79.   (let ((xeno-name (concatenate-symbol 't_$fl name))
  80.         (t-name (concatenate-symbol 'flonum- name)))
  81.     `(block (define-foreign ,xeno-name 
  82.               (,(string-upcase! (symbol->string xeno-name)) (in rep/extend)
  83.                           (in rep/extend)
  84.                           (out rep/extend))
  85.               ignore)
  86.             (define ,t-name (*define-fl-proc-2 ,xeno-name ',t-name)))))
  87.   
  88. (define-local-syntax (define-fl-proc-3 name)
  89.   (let ((xeno-name (concatenate-symbol 't_$fl name))
  90.         (t-name (concatenate-symbol 'flonum- name '?)))
  91.     `(block (define-foreign ,xeno-name 
  92.               (,(string-upcase! (symbol->string xeno-name)) (in rep/extend)
  93.                           (in rep/extend))
  94.               rep/integer)
  95.             (define ,t-name (*define-fl-proc-3 ,xeno-name ',t-name)))))
  96.  
  97. (define-fl-proc-1 sin)
  98. (define-fl-proc-1 cos)
  99. (define-fl-proc-1 tan)
  100. ;(define-fl-proc-1 asin)
  101. ;(define-fl-proc-1 acos)
  102. (define-fl-proc-1 atan)
  103. (define-fl-proc-1 exp)
  104. (define-fl-proc-1 log)
  105. (define-fl-proc-1 sqrt)
  106.  
  107. (define (asin n)
  108.   (error "asin is not yet implemented in aegis t"))
  109. (define (acos n)
  110.   (error "acos is not yet implemented in aegis t"))
  111.  
  112. ;;; ... also need power and atan2
  113.  
  114.  
  115. (define-fl-proc-2 add)
  116. (define-fl-proc-2 subtract)
  117. (define-fl-proc-2 multiply)
  118. (define-fl-proc-2 divide)
  119.  
  120. (define (fl+! x y)
  121.   (t_$fladd x y x))
  122.  
  123. (define (fl-! x y)
  124.   (t_$flsubtract x y x))
  125.  
  126. (define (fl*! x y)
  127.   (t_$flmultiply x y x))
  128.  
  129. (define (fl/! x y)
  130.   (t_$fldivide x y x))
  131.  
  132. (define-fl-proc-3 less)
  133. (define-fl-proc-3 equal)
  134. (define-fl-proc-3 greater)
  135.  
  136.  
  137. (define (flonum-not-equal? a b) (not (flonum-equal? a b)))
  138. (define (flonum-not-less? a b) (not (flonum-less? a b)))
  139. (define (flonum-not-greater? a b) (not (flonum-greater? a b)))
  140.                  
  141. (define (fixnum->flonum fx)
  142.   (let ((fx (enforce fixnum? fx))
  143.         (result (make-flonum)))
  144.     (t_$float fx result)
  145.     result))
  146.            
  147. (define-foreign t_$float 
  148.   ("T_$FLOAT" (in rep/integer)
  149.             (out rep/extend))
  150.     ignore)
  151.  
  152. (define (flonum->fixnum fl)
  153.   (let ((fl (enforce double-float? fl)))
  154.     (t_$fix fl)))
  155.  
  156. (define-foreign t_$fix
  157.   ("T_$FIX" (in rep/extend))
  158.     rep/integer)
  159.  
  160. (define-constant fl+  flonum-add)
  161. (define-constant fl-  flonum-subtract)
  162. (define-constant fl*  flonum-multiply)
  163. (define-constant fl/  flonum-divide)
  164. (define-constant fl=  flonum-equal?)
  165. (define-constant fl<  flonum-less?)
  166. (define-constant fl>  flonum-greater?)
  167. (define-constant fln= flonum-not-equal?)
  168. (define-constant fl>= flonum-not-less?)
  169. (define-constant fl<= flonum-not-greater?)
  170.